home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clx / akcl_dep.lisp next >
Lisp/Scheme  |  1992-04-22  |  4KB  |  116 lines
  1. (in-package "XLIB")
  2.  
  3. #|| ; These are merged into the sources.
  4. (defmacro def-inline (name args return-type flags string)
  5.   (let* ((inline (list args return-type  flags string)))
  6.     `(car (push ',inline (get ',name 'compiler::inline-always)))))
  7.  
  8. (defmacro defun-inline (name args return-type flags string)
  9.   (let* ((sym (gensym))
  10.          (named-args
  11.           (nthcdr (- 10 (length args)) '(X9 X8 X7 X6 X5 X4 X3 X2 X1 X0)))
  12.          (inline (eval `(def-inline ,sym ,args ,return-type ,flags ,string))))
  13.     `(progn
  14.        (defun ,name  ,named-args
  15.          (declare ,@ (sloop::sloop for v in named-args for w in args
  16.                             when (not (eq t v))
  17.                             collect (list w v)))
  18.          (the ,return-type (,sym ,@ named-args)))
  19.        (push  ',inline (get ',name 'compiler::inline-always)))))
  20.  
  21. #+helper
  22. `(progn ,@
  23.       (sloop::sloop 
  24.  for v in '(card29 int8 card8  int16 card16 int32)
  25.  for w in '("unsigned long"
  26.         "char" "unsigned char" "short" "unsigned short" "long")
  27.  for name = (intern (format nil "AREF-~a"v))
  28.  for name-set = (intern (format nil "ASET-~a"v))
  29.  collect
  30.  `(defun-inline  ,name (t fixnum) fixnum #.(compiler::flags compiler::rfa)
  31.      ,(format nil "(*(~a *)(&((#0)->ust.ust_self[#1])))" w))
  32.  collect
  33.  `(defun-inline ,name-set (fixnum t fixnum) fixnum
  34.     #.(compiler::flags set compiler::rfa)
  35.      ,(format nil "(*(~a *)(&((#1)->ust.ust_self[#2])))=(~a)(#0)" w w))))
  36. (PROGN
  37.   (DEFUN-INLINE AREF-CARD29 (T FIXNUM) FIXNUM 8
  38.       "(*(unsigned long *)(&((#0)->ust.ust_self[#1])))")
  39.   (DEFUN-INLINE ASET-CARD29 (FIXNUM T FIXNUM) FIXNUM 10
  40.       "(*(unsigned long *)(&((#1)->ust.ust_self[#2])))=(unsigned long)(#0)")
  41.   (DEFUN-INLINE AREF-INT8 (T FIXNUM) FIXNUM 8
  42.       "(*(char *)(&((#0)->ust.ust_self[#1])))")
  43.   (DEFUN-INLINE ASET-INT8 (FIXNUM T FIXNUM) FIXNUM 10
  44.       "(*(char *)(&((#1)->ust.ust_self[#2])))=(char)(#0)")
  45.   (DEFUN-INLINE AREF-CARD8 (T FIXNUM) FIXNUM 8
  46.       "(*(unsigned char *)(&((#0)->ust.ust_self[#1])))")
  47.   (DEFUN-INLINE ASET-CARD8 (FIXNUM T FIXNUM) FIXNUM 10
  48.       "(*(unsigned char *)(&((#1)->ust.ust_self[#2])))=(unsigned char)(#0)")
  49.   (DEFUN-INLINE AREF-INT16 (T FIXNUM) FIXNUM 8
  50.       "(*(short *)(&((#0)->ust.ust_self[#1])))")
  51.   (DEFUN-INLINE ASET-INT16 (FIXNUM T FIXNUM) FIXNUM 10
  52.       "(*(short *)(&((#1)->ust.ust_self[#2])))=(short)(#0)")
  53.   (DEFUN-INLINE AREF-CARD16 (T FIXNUM) FIXNUM 8
  54.       "(*(unsigned short *)(&((#0)->ust.ust_self[#1])))")
  55.   (DEFUN-INLINE ASET-CARD16 (FIXNUM T FIXNUM) FIXNUM 10
  56.       "(*(unsigned short *)(&((#1)->ust.ust_self[#2])))=(unsigned short)(#0)")
  57.   (DEFUN-INLINE AREF-INT32 (T FIXNUM) FIXNUM 8
  58.       "(*(long *)(&((#0)->ust.ust_self[#1])))")
  59.   (DEFUN-INLINE ASET-INT32 (FIXNUM T FIXNUM) FIXNUM 10
  60.       "(*(long *)(&((#1)->ust.ust_self[#2])))=(long)(#0)"))
  61.  
  62. (defun buffer-read-default (display vector start end timeout)
  63.   (declare (type display display)
  64.        (type buffer-bytes vector)
  65.        (type array-index start end)
  66.        (type (or null (rational 0 *) (float 0.0 *)) timeout))
  67. ; (if *debug-read* (format t "~%doing buffer-read-default ~a(~a)(~a) " display start timeout))
  68.   (let ((stream (display-input-stream display)))
  69.     (declare (type (or null stream) stream))
  70.     (let ((tem (and stream (si::fp-input-stream stream))))
  71.       (if tem (setq stream tem)))
  72.     (or (cond ((null stream))
  73.           ((listen stream) nil)
  74.           ((eql timeout 0) :timeout)
  75.           ((buffer-input-wait-default display timeout)))
  76.     (do* ((index start (index1+ index)))
  77.          ((index>= index end) nil)
  78.       (declare (type array-index index))
  79.       (let ((c (read-byte stream nil -1)))
  80.         (declare (type fixnum c))
  81. ;        (if *debug-read* (format t "(~d)" c))
  82.         (if (eql c -1)
  83.         (return t)
  84.           (setf (aref vector index) (the card8 c))))))))
  85.  
  86. (defun buffer-new-request-number (buffer)
  87.   (declare (type buffer buffer))
  88.   (setf (buffer-request-number buffer)
  89.     (logand #xffff (the card29 (1+ (the card29(buffer-request-number buffer)))))))
  90.  
  91.  
  92.  
  93.  
  94. (defun aset-card32 (v a i &aux (h 0))
  95.   (declare (type card32 v)
  96.        (type buffer-bytes a)
  97.        (type array-index i)
  98.        (type int32 h))
  99.   (if (typep v 'int32)
  100.       (setq h v)
  101.     (setq h (card32->int32 v)))
  102.   (aset-card29 h a i)
  103.   ;(or (eql v (aref-card32 a i)) (print (list me (aref-card32 a i))))
  104.   v)
  105.  
  106. (defun card32->int32 (x)
  107.   (declare (type card32 x))
  108.   (declare (values int32))
  109.   (cond ((typep x 'fixnum)
  110.      x)
  111.     (t  (the int32 (if (logbitp 31 x)
  112.              (the int32 (- x #x100000000))
  113.              x)))))
  114. ||#
  115.   
  116.